home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / IFF / pictures < prev    next >
Encoding:
Text File  |  1992-01-28  |  17.9 KB  |  891 lines
  1. \ High Level Interface to IFF files.
  2. \
  3. \ Load IFF files as pictures or brushes.
  4. \ Brushes will support the necessary structures to
  5. \ transparently draw a bitmap.
  6. \
  7. \ Author: Phil Burk
  8. \ Copyright: Phil Burk 1988
  9. \
  10. \ MOD: PLB 10/20/90 c/dup/pict/ in PIC.TRANS.BLIT for new locals
  11. \ MOD: PLB 11/27/90 PIC-CUR-DISPLAYED OFF in PIC.FREE
  12. \       Reported by Marty Kees
  13. \ MOD: PLB 6/2/91 Added PIC.MAKE by Martin Kees
  14. \ MOD: PLB 6/3/91 Make PIC.DUPLICATE copy bitmaps, see next mod!
  15. \ MOD: PLB 7/2/91 Make PIC.DUPLICATE NOT copy bitmaps
  16. \ MOD: PLB 9/21/91 PIC.TRANS.BLIT now uses BltMaskBitMapRastPort()
  17. \ 00001 PLB 9/23/91 Free color table on error in $PIC.LOAD
  18. \ 00002 PLB 9/25/91 Use Window Rastport for Clipping
  19. \ 00003 PLB 11/12/91 Add save background
  20. \ 00004 PLB 11/13/91 Do not use first pictures RastPort
  21. \       Add $PIC.LOAD? and PIC.OPEN? for proper error handling.
  22. \ 00005 PLB 11/13/91 Remove PIC.?BREAK call cuz it messed up Input
  23. \ 00006 PLB 11/27/91 Support non-zero transparent color, fix PIC.LOAD
  24. \ 00007 PLB 1/7/92 Changed PIC.MAKE to PIC.MAKE?, reversed flag
  25. \ 00008 PLB 1/28/92 Check BITMAPS= in PIC.USE.BITMAP for PIC.DISPLAY
  26.  
  27. \ This loads everything needed.
  28. getmodule includes
  29. include? siff-screen jiff:show_iff
  30. include? task-ilbm_maker jiff:ilbm_maker
  31. decimal
  32. ANEW TASK-PICTURES
  33.  
  34. \ Define special structure for manipulating IFF based pictures.
  35. \ Pointers are relative pointers.
  36. :STRUCT PICTURE
  37.     LONG  PIC_KEY
  38.     RPTR  PIC_BITMAP
  39.     RPTR  PIC_VIEW
  40.     RPTR  PIC_CTABLE
  41.     RPTR  PIC_RASTPORT
  42.     RPTR  PIC_SHADOW
  43.     RPTR  PIC_BACKUP_0
  44.     SHORT PIC_BACKUP_0_X
  45.     SHORT PIC_BACKUP_0_Y
  46.     RPTR  PIC_BACKUP_1
  47.     SHORT PIC_BACKUP_1_X
  48.     SHORT PIC_BACKUP_1_Y
  49.     USHORT PIC_TransparentColor \ 00006
  50.     SHORT PIC_NUM_COLORS
  51.     SHORT PIC_DST_X
  52.     SHORT PIC_DST_Y
  53.     SHORT PIC_DST_XOFF  ( these offsets will be added to x,y )
  54.     SHORT PIC_DST_YOFF
  55.     SHORT PIC_SRC_X
  56.     SHORT PIC_SRC_Y
  57.     SHORT PIC_SRC_W
  58.     SHORT PIC_SRC_H
  59. \ Parameters for special effects.
  60.     BYTE  PIC_IF_DISP   ( true if currently displayed )
  61.     BYTE  PIC_DIRECTION
  62.     SHORT PIC_WIPE_XOFF
  63.     SHORT PIC_WIPE_YOFF
  64.     SHORT PIC_WIPE_W
  65.     SHORT PIC_WIPE_H
  66.     LONG  PIC_COUNT
  67. ;STRUCT
  68.  
  69. $ 19a5ef27 constant PIC_VALID_KEY
  70. variable PIC-CUR-DISPLAYED  ( variable pointing to displayed picture )
  71. variable PIC-CLIPPING
  72. true pic-clipping !
  73. variable PIC-CUR-MINTERM
  74. variable PIC-CUR-MASK
  75. variable PIC-USE-GRABXY  ( if true, set dst_x/yoff in picture )
  76.  
  77. $ 0C0 pic-cur-minterm !
  78. $ 0FF pic-cur-mask !
  79.  
  80. \ Call a deferred word if closebox hit.
  81. defer PIC.CLOSEBOX
  82. ' noop is pic.closebox
  83.  
  84. : PIC.?BREAK  ( -- , test for user break )
  85.     ?closebox ?terminal OR
  86.     IF pic.closebox
  87.     THEN
  88. ;
  89.  
  90. : PIC.CHECK ( picture -- , abort if bad )
  91.     s@ pic_key
  92.     pic_valid_key -
  93.     abort" Invalid or Empty Picture!"
  94. \    pic.?break \ 00005
  95. ;
  96.  
  97. : PIC.PUT.XY ( x y picture -- , set source x and y )
  98.     dup pic.check
  99.     tuck s! pic_src_y
  100.     s! pic_src_x
  101. ;
  102.  
  103. : PIC.GET.XY ( picture -- x y , fetch source x and y )
  104.     dup s@ pic_src_x
  105.     swap s@ pic_src_y
  106. ;
  107.  
  108. : PIC.PUT.XYOFF ( x y picture -- , set x,y offsets )
  109.     dup pic.check
  110.     tuck s! pic_dst_yoff
  111.     s! pic_dst_xoff
  112. ;
  113. : PIC.GET.XYOFF ( picture -- x y , fetch x,y offsets )
  114.     dup s@ pic_dst_xoff
  115.     swap s@ pic_dst_yoff
  116. ;
  117.  
  118. : PIC.PUT.WH ( width height picture -- , set source width and height )
  119.     dup pic.check
  120.     tuck s! pic_src_h
  121.     s! pic_src_w
  122. ;
  123.  
  124. : PIC.GET.WH ( picture -- w h , fetch source w and h )
  125.     dup s@ pic_src_w
  126.     swap s@ pic_src_h
  127. ;
  128.  
  129. : PIC.FREE  ( picture -- , free all parts of picture )
  130.     dup s@ pic_key
  131.     pic_valid_key =
  132.     IF  >r  ( save on RS )
  133. \ Check to see if displayed, close screen if so.
  134.         r@ s@ pic_if_disp
  135.         IF siff.close  0 r@ s! pic_if_disp
  136.             pic-cur-displayed off  \ M901127-0
  137.         THEN
  138. \
  139. \ Free various parts.
  140.         r@ s@ pic_bitmap ?dup
  141.         IF free.bitmap
  142.             0 r@ s! pic_bitmap
  143.         THEN
  144. \
  145.         r@ s@ pic_view ?dup
  146.         IF
  147.             free.view
  148.             0 r@ s! pic_view
  149.         THEN
  150. \
  151.         r@ .. pic_ctable freevar
  152.         r@ .. pic_rastport freevar
  153.         r@ s@ pic_shadow ?dup
  154.         IF free.shadow
  155.             0 r@ s! pic_shadow
  156.         THEN
  157.         r@ s@ pic_backup_0 ?dup
  158.         IF free.bitmap
  159.             0 r@ s! pic_backup_0
  160.         THEN
  161.         r@ s@ pic_backup_1 ?dup
  162.         IF free.bitmap
  163.             0 r@ s! pic_backup_1
  164.         THEN
  165.         r@ sizeof() picture erase  ( clear whole thing including key )
  166.         rdrop
  167.     ELSE drop
  168.     THEN
  169. ;
  170.  
  171. : PIC.GET.DEPTH ( picture -- depth )
  172.     s@ pic_bitmap s@ bm_depth
  173. ;
  174.  
  175. : CLIP.1D.2RECT
  176. { src smany ssize dst dsize -- src' dst' smany' }
  177. \ Check trivial rejections
  178.     src smany + 0< IF 0 0 0 return THEN
  179.     src ssize 1- > IF 0 0 0 return THEN
  180.     dst dsize 1- > IF 0 0 0 return THEN
  181.     src 0<
  182.     IF  smany src + -> smany
  183.         dst src - -> dst
  184.         0 -> src
  185.     ELSE
  186.         src ssize 1- >
  187.         IF return
  188.         THEN
  189.     THEN
  190.     dst smany + 0< IF 0 0 0 return THEN
  191.     dst 0<
  192.     IF  smany dst + -> smany
  193.         src dst - -> src
  194.         0 -> dst
  195.     THEN
  196.     src smany + ssize >
  197.     IF  ssize src - -> smany
  198.     THEN
  199.     dst smany + dsize >
  200.     IF dsize dst - -> smany
  201.     THEN
  202.     src dst smany
  203. ;
  204.  
  205. : CLIP.BLIT.PARAMS \ clip parameters
  206. { s??? sbmap srcx srcy d??? dbmap dstx dsty srcw srch --  SEE_NEXT_LINE }
  207. ( -- s??? srcx srcy d??? dstx dsty srcw srch true | 0 )
  208.     FALSE \ default return
  209. \
  210. \ clip parameters to edges of bitmaps
  211. \ First check x dimension
  212.     srcx  srcw
  213.     sbmap s@ bm_bytesperrow 3 ashift  ( src_size )
  214.     dstx
  215.     dbmap s@ bm_bytesperrow 3 ashift ( dst_size )
  216.     clip.1d.2rect  -> srcw -> dstx -> srcx
  217. \
  218. \ Now check y dimension
  219.     srcw 0>
  220.     IF
  221.         srcy
  222.         srch
  223.         sbmap s@ bm_rows
  224.         dsty
  225.         dbmap s@ bm_rows
  226.         clip.1d.2rect -> srch -> dsty -> srcy
  227. \
  228. \ return all parameters modified
  229.         srch 0>
  230.         IF
  231.             drop \ get rid of FALSE flag
  232.             s??? srcx srcy d??? dstx dsty srcw srch TRUE
  233.         THEN
  234.     THEN
  235. ;
  236.  
  237. : (PIC.CLIP.BLIT) { dstx dsty pict -- , blit to x,y }
  238. \ Blit rastport of a picture.
  239.     pict s@ pic_rastport
  240.     dup s@ rp_bitmap
  241.     pict s@ pic_src_x
  242.     pict s@ pic_src_y
  243.     gr-currport @ >rel
  244.     dup s@ rp_bitmap
  245. \ Add offsets from handles.
  246.     dstx pict s@ pic_dst_xoff +
  247.     dsty pict s@ pic_dst_yoff +
  248.     pict s@ pic_src_w
  249.     pict s@ pic_src_h
  250. \
  251.     clip.blit.params
  252.     IF
  253.         pic-cur-minterm @
  254.         ClipBlit()
  255.     THEN
  256. ;
  257.  
  258. : (PIC.BLIT) { dstx dsty pict  -- , blit to x,y }
  259.     pict s@ pic_rastport
  260.     pict s@ pic_src_x
  261.     pict s@ pic_src_y
  262.     gr-currport @ >rel
  263. \ Add offsets from handles.
  264.     dstx pict s@ pic_dst_xoff +
  265.     dsty pict s@ pic_dst_yoff +
  266.     pict s@ pic_src_w
  267.     pict s@ pic_src_h
  268.     pic-cur-minterm @
  269.     ClipBlit()
  270. ;
  271.  
  272. : PIC.BLIT ( dstx dsty pict  -- , blit to x,y )
  273. \ Blit rastport of a picture.
  274.     dup pic.check
  275.     dup s@ pic_rastport
  276.     IF
  277. \ clip if desired
  278.         PIC-CLIPPING @
  279.         IF
  280.             (pic.clip.blit)
  281.         ELSE
  282.             (pic.blit)
  283.         THEN
  284.     ELSE ." PIC.BLIT - No Source RastPort!" cr
  285.     THEN
  286. ;
  287.  
  288.  
  289. : PIC.ALLOC.SHADOW? ( picture -- error? , allocate a shadow bitmap )
  290.     dup>r pic.check
  291.     r@ s@ pic_shadow
  292.     IF \ already got one
  293.         FALSE
  294.     ELSE
  295.         r@ pic.get.depth
  296.         r@ s@ pic_bitmap bitmap>wh
  297.         alloc.shadow ?dup
  298.         IF r@ s! pic_shadow FALSE
  299.         ELSE ." Couldn't allocate Shadow Bitmap!" cr TRUE
  300.         THEN
  301.     THEN
  302.     rdrop
  303. ;
  304.  
  305. : PIC.ALLOC.SHADOW  ( picture -- , allocate a shadow bitmap )
  306.     pic.alloc.shadow? drop  \ historically we did not abort
  307. \ check shadow field after this call
  308. ;
  309.  
  310. : PIC.GET.NTH.BACKUP ( n picture -- bitmap )
  311.     swap
  312.     IF
  313.         s@ pic_backup_1
  314.     ELSE
  315.         s@ pic_backup_0
  316.     THEN
  317. ;
  318.  
  319. : PIC.PUT.NTH.BACKUP ( bitmap n picture -- )
  320.     swap
  321.     IF
  322.         s! pic_backup_1
  323.     ELSE
  324.         s! pic_backup_0
  325.     THEN
  326. ;
  327.  
  328. : PIC.ALLOC.BACKUP?  { backup# pict | bmap -- error? , allocate a backup bitmap }
  329.     pict pic.check
  330.     backup# pict pic.get.nth.backup -> bmap \ do we already have one?
  331.     bmap 0=
  332.     IF
  333.         pict pic.get.depth
  334.         pict s@ pic_bitmap bitmap>wh
  335.         alloc.bitmap ?dup
  336.         IF
  337.             dup -> bmap
  338.             backup# pict pic.put.nth.backup
  339.         THEN
  340.     THEN
  341.     bmap 0=
  342. ;
  343.  
  344. : COPY.BITMAP  { srcmap dstmap -- , copy same sized bitmaps }
  345.     srcmap  0 0
  346.     dstmap  0 0
  347.     srcmap bitmap>wh
  348.     pic-cur-minterm @
  349.     pic-cur-mask @
  350.     0 ( use TEMPA = 0 since not overlapping )
  351.     BltBitMap()
  352. ;
  353.  
  354. \ Calculation of MINTERM for OR of inverse transparent color planes
  355. \ 0 0 0 = 0
  356. \ 0 0 1 = 0
  357. \ 0 1 0 = 0
  358. \ 0 1 1 = 0
  359. \ 1 0 0 = 1  \ on if source is zero, must be one to match trans color
  360. \ 1 0 1 = 1
  361. \ 1 1 0 = 0
  362. \ 1 1 1 = 1  \ on to preserve bits from before
  363. \ MinTerm = $B0
  364.  
  365. : PIC.CAST.SHADOW { pict | shadow -- , cast bitmap into shadow }
  366.     pict pic.check
  367.     pict s@ pic_shadow dup -> shadow
  368.     IF
  369. \ clear that bitplane in case not already clear
  370.         0 shadow bmplane[] @ >rel
  371.         shadow @ word-swap 3 BltClear()
  372. \
  373.         pic-cur-minterm @ >r 
  374. \ check transparent color 00006
  375.         pict s@ pic_TransparentColor 0=
  376.         IF
  377. \ copy bitmap to cast shadow for color zero
  378.             $ 0E0 pic-cur-minterm !  \ OR source
  379.             pict s@ pic_bitmap
  380.             shadow
  381.             copy.bitmap
  382.         ELSE
  383. \ for color other then zero we must do two blits.
  384. \ First the normal blit for the zero planes
  385.             pict s@ pic_transparentColor $ 0FF XOR
  386.             pic-cur-mask !
  387.             $ 0E0 pic-cur-minterm ! \ OR Source
  388.             pict s@ pic_bitmap
  389.             shadow
  390.             copy.bitmap
  391. \ now the inverse blit for the one planes 00006
  392.             pict s@ pic_transparentColor
  393.             pic-cur-mask !
  394.             $ 0B0 pic-cur-minterm ! \ OR Source
  395.             pict s@ pic_bitmap
  396.             shadow
  397.             copy.bitmap
  398.             $ 0FF pic-cur-mask !
  399.         THEN
  400.         r> pic-cur-minterm !
  401.     ELSE ." No Shadow Allocated!" cr
  402.     THEN
  403. ;
  404.  
  405. : PIC.BACKUP.NTH { dstx dsty backup# pict | dbmap -- }
  406. \ Warning - Do not set x,y,w,h so that you go past
  407. \ the picture bounds.
  408.     backup# pict pic.get.nth.backup -> dbmap
  409.     dbmap
  410.     IF
  411.         gr-currport @ ?dup
  412.         IF
  413.             >rel s@ rp_bitmap
  414.             dup
  415. \ Add offsets from handles.
  416.             dstx pict s@ pic_dst_xoff + dup -> dstx
  417.             dsty pict s@ pic_dst_yoff + dup -> dsty
  418.             dbmap
  419.             dup
  420. \ use current x,y,w,h from picture to avoid moving too much
  421.             pict s@ pic_src_x
  422.             pict s@ pic_src_y
  423.             pict s@ pic_src_w
  424.             pict s@ pic_src_h
  425. \
  426. \ force clip because no protection for bitmaps
  427.             clip.blit.params
  428.             IF
  429.                 pic-cur-minterm @
  430.                 pic-cur-mask @
  431.                 0 ( use TEMPA = 0 since not overlapping )
  432.                 BltBitMap()
  433.             THEN
  434. \
  435. \ set saved x,y for restore
  436.             backup#
  437.             IF
  438.                 dstx pict s! pic_backup_1_x
  439.                 dsty pict s! pic_backup_1_y
  440.             ELSE
  441.                 dstx pict s! pic_backup_0_x
  442.                 dsty pict s! pic_backup_0_y
  443.             THEN
  444.         ELSE
  445.             ." PIC.BACKUP.NTH - No Source Rastport!" cr
  446.         THEN
  447.     ELSE
  448.         ." PIC.BACKUP.NTH - No Save Bitmap!" cr
  449.     THEN
  450. ;
  451.  
  452. : PIC.RESTORE.NTH { backup# pict | bmap rport -- }
  453. \ always does pic-clipping
  454.     backup# pict pic.get.nth.backup -> bmap
  455.     bmap
  456.     IF
  457.         gr-currport @ ?dup
  458.         IF
  459.             >rel -> rport
  460. \ load parameters
  461.             bmap
  462.             dup 
  463.             pict s@ pic_src_x
  464.             pict s@ pic_src_y
  465.             rport
  466.             dup s@ rp_bitmap
  467. \ get saved x,y
  468.             backup#
  469.             IF
  470.                 pict s@ pic_backup_1_x
  471.                 pict s@ pic_backup_1_y
  472.             ELSE
  473.                 pict s@ pic_backup_0_x
  474.                 pict s@ pic_backup_0_y
  475.             THEN
  476.             pict s@ pic_src_w
  477.             pict s@ pic_src_h
  478.             clip.blit.params
  479.             IF
  480.                 pic-cur-minterm @
  481. \
  482.                 BltBitMapRastPort()
  483.             THEN
  484.         ELSE
  485.             ." PIC.RESTORE.NTH - No Target Rastport!" cr
  486.         THEN
  487.     ELSE
  488.         ." PIC.RESTORE.NTH - No Saved Bitmap!" cr
  489.     THEN
  490. ;
  491.  
  492. : CLIP.BLIT.MASKBIT { bmap srcx srcy dstx dsty srcw srch mterm bmask -- }
  493. \ Clip and see if anything left.
  494.     pic-clipping @
  495. \ First check x dimension
  496.     IF
  497.         srcx  srcw
  498.         bmap s@ bm_bytesperrow 3 ashift  ( srcsize )
  499. \
  500.         dstx
  501.         gr-currport @ >rel s@ rp_bitmap
  502.         s@ bm_bytesperrow 3 ashift ( dsize )
  503.         clip.1d.2rect  -> srcw -> dstx -> srcx
  504.     THEN
  505. \
  506. \ Now check y dimension
  507.     srcw 0>
  508.     IF
  509.         pic-clipping @
  510.         IF
  511.             srcy
  512.             srch
  513.             bmap s@ bm_rows
  514.             dsty
  515.             gr-currport @ >rel s@ rp_bitmap s@ bm_rows
  516.             clip.1d.2rect -> srch -> dsty -> srcy
  517.         THEN
  518. \
  519.         srch 0>
  520.         IF  bmap
  521.             srcx srcy
  522.             gr-currport @ >rel
  523.             dstx dsty
  524.             srcw srch
  525.             mterm
  526.             bmask
  527.             BltMaskBitMapRastPort()
  528.         THEN
  529.     THEN
  530. ;
  531.  
  532.  
  533. : PIC.TRANS.BLIT { dstx dsty pict -- , blit transparently }
  534.     pict pic.check
  535.     pict s@ pic_shadow 0=
  536.     IF  pict pic.alloc.shadow
  537.         pict pic.cast.shadow
  538.     THEN
  539. \
  540.     pict s@ pic_shadow
  541.     IF
  542.         pict s@ pic_bitmap
  543.         pict s@ pic_src_x
  544.         pict s@ pic_src_y
  545. \ Add offsets from handles.
  546.         dstx pict s@ pic_dst_xoff +
  547.         dsty pict s@ pic_dst_yoff +
  548.         pict s@ pic_src_w
  549.         pict s@ pic_src_h
  550.         $ E0
  551.         0 pict s@ pic_shadow bmplane[] @ >rel
  552.         clip.blit.MaskBit
  553.     ELSE ." PIC.TRANS.BLIT - No Shadow!"
  554.     THEN
  555. ;
  556.  
  557. : PIC.MAKE.RASTPORT? ( picture -- error? , create RastPort from current Bitmap )
  558.     dup pic.check
  559.     >r alloc.rastport ?dup
  560.     IF  dup r@ s! pic_rastport ( -- rp )
  561.         r@ s@ pic_bitmap  ( -- rp bm )
  562.         swap link.bm>rp
  563.         FALSE
  564.     ELSE ." Could not allocate RastPort!" cr TRUE
  565.     THEN
  566.     rdrop
  567. ;
  568.  
  569. : PIC.MAKE.RASTPORT ( picture -- , create RastPort from current Bitmap )
  570.     pic.make.rastport? abort" PIC.MAKE.RASTPORT - failed!"
  571. ;
  572.  
  573. : PIC.DRAWTO ( picture -- , make this the destination )
  574.     dup pic.check  ( -- pic )
  575.     dup s@ pic_rastport 0= ( -- pic flag )
  576.     IF ( -- pic )
  577.         dup pic.make.rastport? abort"  No Rastport!"
  578.     THEN ( -- pic )
  579.     s@ pic_rastport    >abs gr-currport !
  580. ;
  581.  
  582. : PIC.COPY { srcpic dstpic -- , copy bitmaps and color table }
  583. \ You must make sure these are the same size!
  584. \ Use PIC.DUPLICATE
  585.     srcpic s@ pic_bitmap
  586.     dstpic s@ pic_bitmap
  587.     copy.bitmap
  588.     srcpic s@ pic_ctable ?dup
  589.     IF  dstpic s@ pic_ctable ?dup
  590.         IF srcpic s@ pic_num_colors 2* cmove
  591.         ELSE drop
  592.         THEN
  593.     THEN
  594. ;
  595.  
  596. : PIC.DUPLICATE?  { srcpic dstpic -- error? , make copy of picture }
  597.     srcpic pic.check
  598.     dstpic pic.free
  599. \
  600. \ Make same size bitmap.
  601.     srcpic pic.get.depth
  602.     srcpic pic.get.wh
  603.     alloc.bitmap ?dup
  604.     IF  dstpic s! pic_bitmap
  605.         pic_valid_key dstpic s! pic_key
  606.     ELSE
  607.         goto.error
  608.     THEN
  609. \
  610. \ Copy window values
  611.     srcpic pic.get.wh dstpic pic.put.wh
  612.     srcpic pic.get.xy dstpic pic.put.xy
  613. \
  614. \ Copy color table
  615.     memf_clear srcpic s@ pic_num_colors 2* allocblock ?dup
  616.     IF  dup dstpic s! pic_ctable
  617.         srcpic s@ pic_ctable swap
  618.         srcpic s@ pic_num_colors 2* cmove
  619.         srcpic s@ pic_num_colors dstpic s! pic_num_colors
  620.     ELSE
  621.         goto.error
  622.     THEN
  623.     dstpic pic.make.rastport? ?goto.error
  624.     false
  625.     exit
  626. \
  627. ERROR:
  628.     dstpic pic.free
  629.     true
  630. ;
  631.  
  632. : PIC.DUPLICATE  ( srcpic dstpic -- , make copy of picture )
  633.     pic.duplicate?
  634.     IF
  635.         ." PIC.DUPLICATE failed!" cr
  636.     THEN
  637. ;
  638.  
  639. : PIC.USE.COLORS ( picture -- , apply colors to screen )
  640.     dup pic.check
  641.     dup>r s@ pic_ctable
  642.     IF  r@ s@ pic_ctable  r@ s@ pic_num_colors
  643.         siff.use.ctable
  644.     THEN
  645.     rdrop
  646. ;
  647.  
  648. variable PIC-START-BLACK
  649.  
  650. : PIC.OPEN? { pict -- screen | 0 , open screen based on picture }
  651. \ Use viewmodes from CAMG chunk. 00004
  652.     pict s@ pic_bitmap ilbm-camg @ bitmap>screen ?dup
  653.     IF
  654.         dup siff-screen !
  655.         screen>backwindow ?dup
  656.         IF
  657.             siff-window !
  658. \ Set to proper color map.
  659.             pic-start-black @
  660.             IF  siff.blackout
  661.             ELSE pict pic.use.colors
  662.             THEN pic-start-black off
  663. \ (00002) siff-screen @ .. sc_rastport >abs gr-currport ! 
  664.             siff.showit
  665.         ELSE
  666.             siff.close
  667.         THEN
  668.     ELSE drop
  669.     THEN
  670.     siff-screen @
  671. ;
  672.  
  673. : PIC.OPEN ( picture -- , abort if can't open screen )
  674.     pic.open? 0= abort" PIC.OPEN - Could not open screen!"
  675. ;
  676.  
  677. : PIC.WHOLE ( picture -- , reset bounds to use whole picture)
  678.     dup>r pic.check
  679.     r@ s@ pic_bitmap bitmap>wh
  680.     r@ pic.put.wh
  681.     0 0 r@ pic.put.xy
  682.     rdrop
  683. ;
  684.  
  685. : PIC.MARK.DISPLAYED  ( picture -- , mark as displayed picture )
  686.     pic-cur-displayed @ ?dup
  687.     IF  0 swap s! pic_if_disp   ( flag old one NOT displayed )
  688.     THEN
  689.     dup pic-cur-displayed !
  690.     true swap s! pic_if_disp
  691. ;
  692.  
  693. : PIC.BUILD  ( bitmap picture -- , make picture from bitmap )
  694.     dup>r pic.free
  695.     r@ s! pic_bitmap
  696.     pic_valid_key r@ s! pic_key
  697.     r@ pic.make.rastport
  698.     r@ pic.whole
  699.     rdrop
  700. ;
  701.  
  702. : $PIC.LOAD? { $iff-filename pict | bmap -- error? , load iff picture }
  703.     depth 0< abort" $PIC.LOAD - Missing Parameters!"
  704. \
  705.     graphics_lib @ 0=
  706.     IF
  707.         >newline
  708.         ." GR.INIT should be called before $PIC.LOAD?" cr
  709.         gr.init
  710.     THEN
  711. \
  712.     pict pic.free
  713.     $iff-filename $ilbm.parse.file? ?GOTO.ERROR
  714. \
  715. \ set transparent color
  716.     ilbm-header s@ bmh_transparentColor
  717.     pict s! pic_TransparentColor
  718. \
  719. \ Color Table
  720.     ilbm.make.ctable  pict s! pic_num_colors
  721.     pict s! pic_ctable
  722. \
  723. \ create appropriately sized bitmap
  724.     ilbm.alloc.bitmap dup -> bmap pict s! pic_bitmap
  725.     bmap 0= ?GOTO.ERROR
  726. \
  727.     pic_valid_key pict s! pic_key
  728.     pict pic.make.rastport
  729.     siff-screen @ 0=
  730.     IF
  731.         pict s@ pic_rastport 0 SetRast()  ( start clear )
  732.         pict pic.open? 0= ?goto.error
  733.         pict pic.mark.displayed
  734. \ 00004            pict pic.drawto    ( use it's rastport )
  735.     THEN
  736. \
  737. \ fill bitmap now that we have a screen
  738.     bmap ilbm.fill.bitmap 0= ?GOTO.ERROR
  739.     pict pic.whole
  740. \
  741. \ set handles
  742.     pic-use-grabxy @
  743.     IF ilbm-grabxy w@ w->s negate
  744.         ilbm-grabxy 2+ w@ w->s negate
  745.         pict pic.put.xyoff
  746.     THEN
  747.     ilbm.cleanup
  748.     FALSE
  749.     exit
  750. \
  751. ERROR:
  752.     ilbm.cleanup
  753.     pict pic.free
  754.     TRUE
  755. ;
  756.  
  757. : $PIC.LOAD (  $iff-filename picture -- , load iff picture )
  758.     $pic.load?
  759.     IF
  760.         ." $PIC.LOAD - Could not load picture!" cr
  761.     THEN
  762. ;
  763.  
  764. : PIC.LOAD? ( picture <filename> -- error? , load IFF picture )
  765.     fileword swap $pic.load?
  766. ;
  767.  
  768. : PIC.LOAD ( picture <filename> -- , load IFF picture )
  769.     fileword swap $pic.load
  770. ;
  771.  
  772. : PIC.USE.BITMAP ( picture -- )
  773.     dup>r pic.check
  774.     r@ s@ pic_bitmap
  775.     siff-screen @ .. sc_bitmap
  776.     2dup bitmaps= \ 00008
  777.     IF
  778.         copy.planes
  779. \
  780.         siff-screen @ remake.screen
  781. \
  782. \ Keep track of who is displayed.
  783.         r@ pic.mark.displayed
  784.     ELSE
  785.         2drop
  786.         ." PIC.USE.BITMAP - bitmaps not equal in size!" cr
  787.     THEN
  788.     rdrop
  789. ;
  790.  
  791. : PIC.DISPLAY ( picture -- , display picture by copying bitmaps )
  792.     pic-start-black @
  793.     IF siff.blackout
  794.     ELSE dup pic.use.colors
  795.     THEN pic-start-black off
  796.     pic.use.bitmap
  797. ;
  798.  
  799. : PIC.ALLOC.VIEW? { pict -- error? }
  800.     pict s@ pic_view 0=
  801.     IF
  802.         pict pic.display
  803.         siff-screen @ screen>view
  804.         dup pict s! pic_view
  805.         0=
  806.     ELSE
  807.         FALSE
  808.     THEN
  809. ;
  810.  
  811. : PIC.VIEW ( picture -- , display a pictures view )
  812.     dup pic.alloc.view? 0= \ just in case
  813.     IF
  814.         s@ pic_view LoadView()
  815.     ELSE
  816.         drop ." PIC.VIEW - could not make view!" cr
  817.     THEN
  818. ;
  819.  
  820. \ Save a modified picture.
  821. : $PIC.SAVE? { $filename pict -- error? , save picture to IFF file }
  822.     pict pic.check
  823.     pict s@ pic_if_disp
  824.     IF siff-screen @ $filename $screen>iff?
  825.     ELSE
  826.         new $filename $iff.open?
  827.         IF
  828.             pict s@ pic_bitmap
  829.             pict s@ pic_ctable 
  830.             pict s@ pic_num_colors
  831.             ilbm.write.ilbm?
  832.             iff.close
  833.         ELSE
  834.             TRUE
  835.         THEN
  836.     THEN
  837. ;
  838.  
  839. : PIC.SAVE? ( picture <filename> -- error? )
  840.     fileword swap $pic.save?
  841. ;
  842.  
  843.  
  844. : $PIC.SAVE ( $filename picture -- , save picture to IFF file )
  845.     $pic.save?
  846.     IF
  847.         ." $PIC.SAVE failed!" cr
  848.     THEN
  849. ;
  850.  
  851. : PIC.SAVE ( picture <filename> -- )
  852.     pic.save?
  853.     IF
  854.         ." PIC.SAVE failed!" cr
  855.     THEN
  856. ;
  857.  
  858. \ Make a picture from scratch.  Martin Kees, 00007
  859. : PIC.MAKE?  { colrtab #colors deep wide high pict -- error? , true if error }
  860.     pict pic.free
  861.     deep wide high alloc.bitmap ?dup
  862.     IF
  863.         pict s! pic_bitmap
  864.         pic_valid_key pict s! pic_key
  865.         pict pic.make.rastport
  866.         wide high pict pic.put.wh
  867.         0 0 pict  pic.put.xy
  868.         colrtab
  869.         IF
  870.             memf_clear #colors 2* allocblock ?dup
  871.             IF
  872.                 dup pict s! pic_ctable
  873.                 colrtab swap #colors 2* cmove
  874.                 #colors pict s! pic_num_colors
  875.             ELSE
  876.                 true exit
  877.             THEN
  878.         THEN
  879.         false \ all OK
  880.     ELSE
  881.         true \ there was an error
  882.     THEN
  883. ;
  884.  
  885.  
  886. : PIC.CLONE ( src dest --- , copy image of src to dest )
  887.     pic.drawto
  888.     0 0 rot pic.blit
  889. ;
  890.  
  891.